home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / equality.t < prev    next >
Text File  |  1988-05-02  |  4KB  |  104 lines
  1. (herald equality (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Exact
  27. ;++ Where should this be defined?
  28.  
  29. (define (exact? n)
  30.   (cond ((fixnum?   n) '#t)   ; avoid the procedure call to integer
  31.         ((bignum?   n) '#t)
  32.         ((rational? n) '#t)
  33.         (else '#f)))
  34.  
  35. ;;; Various equality predicates.
  36.  
  37. ;++ fix for generic numbers
  38. (define (equiv? a b)
  39.     (or (eq? a b)
  40.     (cond ((float? a) (and (float? b) (fl= a b)))
  41.           ((bignum? a) (and (bignum? b) (bignum-equal? a b)))
  42.           ((hacked-ratio? a) (and (hacked-ratio? b) (rational-equal? a b)))
  43.           ((string? a) (and (string? b) (string-equal? a b)))
  44.           (else '#f))))
  45.  
  46. (define hacked-ratio?
  47.   (let ((tem (extend-header (ratio 1 2))))
  48.     (lambda (x)
  49.       (and (extend? x) (eq? (extend-header x) tem)))))
  50.   
  51.  
  52. (define (eqv? a b)
  53.   (or (eq? a b)
  54.       (and (char? a) (char? b) (char= a b))  ;++ make sure of this!
  55.       (and (fixnum? a) (fixnum? b) (fx= a b))
  56.       (and (exact? a) (exact? b) (= a b))))
  57.  
  58. (define-recursive (equal? a b)
  59.   (or (eq? a b)
  60.       (and (number? a)  (number? b)  (= a b))
  61.       (and (string? a) (string? b) (%string-equal? a b))
  62.       (and (pair? a)   (pair? b)   (alikeq? a b))
  63.       (and (vector? a)
  64.            (vector? b)
  65.            (fx= (vector-length a) (vector-length b))
  66.            (let ((len (vector-length a)))
  67.              (iterate loop ((i 0))
  68.                (cond ((fx>= i len) '#t)
  69.                      ((equal? (vref a i) (vref b i))
  70.                       (loop (fx+ i 1)))
  71.                      (else '#f)))))
  72.       ;++ add arrays later
  73.       ))
  74.  
  75. (define-integrable (not-equal? a b) (not (equal? a b)))
  76.  
  77. (define (alike? pred exp1 exp2)
  78.   (iterate loop ((exp1 exp1) (exp2 exp2))
  79.     (cond ((eq? exp1 exp2) t)             ; speed hack
  80.           ((atom? exp1)
  81.            (if (atom? exp2) (pred exp1 exp2) nil))
  82.           ((atom? exp2) nil)
  83.           ((loop (car exp1) (car exp2))
  84.            (loop (cdr exp1) (cdr exp2)))
  85.           (else nil))))
  86.  
  87. (define-recursive (alikeq? exp1 exp2)  ; i like q, 2
  88.   (cond ((eq? exp1 exp2) t)             ; speed hack
  89.         ((atom? exp1)
  90.          (if (atom? exp2) (eq? exp1 exp2) nil))
  91.         ((atom? exp2) nil)
  92.         ((alikeq? (car exp1) (car exp2))
  93.          (alikeq? (cdr exp1) (cdr exp2)))
  94.         (else nil)))
  95.  
  96. (define-recursive (alikev? exp1 exp2)
  97.   (cond ((eq? exp1 exp2) t)             ; speed hack
  98.         ((atom? exp1)
  99.          (if (atom? exp2) (equiv? exp1 exp2) nil))
  100.         ((atom? exp2) nil)
  101.         ((alikev? (car exp1) (car exp2))
  102.          (alikev? (cdr exp1) (cdr exp2)))
  103.         (else nil)))
  104.